Imports System.Math
Public Class FGalaxyForm1
Public xstr(40), xend(40), ystr(40), yend(40)
Const pictdim% = 40 ' maximum picture number - array size
Const Maxpixels = 2000
Public kl(2, 30), rgbx(2) ' GETcoulour1
Public xmax, ymax, xchrmax, ychrmax, lfn
Public xcenter, ycenter
Public colour As Long
Public xp1, yp1, xp2, yp2 ' Form1 top_left bottom_right
Public picture As Integer ' current picture number
Public picture1, picture0 As Integer ' current picture number
Public countmax
Public Amplification_old, Amplification
Public swidth, sheight
Public width1, height1
Public pos, ipnt
Public var(4) As Long
Public blank, testblank
Public dirname, filenm, flname As String
Public state
Public buffersize As Integer
Public inputfile
Public Const trace = 0
Const posmax = 50
Private Sub ButtonStart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ButtonStart.Click
Dim ip As Integer
GETScreen()
Debug.Print("Command Start Height" + Str(Me.Height) + "Width" + Str(Me.Width))
ip = Val(Me.TBpicture.Text)
picture1 = ip
Debug.Print("Command Start" + Str(ymax) + "Width" + Str(xmax))
Main()
End Sub
Private Sub ButtonEnd_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ButtonEnd.Click
End
End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
FGalaxyForm2.Visible = True
xstr(0) = -3 : xend(0) = 2 : ystr(0) = -2.5 : yend(0) = 2.5
xstr(0) = -2.8 : xend(0) = 1.8 : ystr(0) = -2.3 : yend(0) = 2.3
xp1 = 0 : xp2 = 1
yp1 = 0 : yp2 = 1
Amplification = 1
Amplification_old = 1
Me.TBpicture.Text = 0 ' Picture nr
Me.TBxp1.Text = xp1 ' x1 %
Me.TByp1.Text = yp1 ' y1 %
Me.TBxp2.Text = xp2 ' x2 %
Me.TByp2.Text = yp2 ' y2 %
Me.TBamplification.Text = Amplification
state = 0
INITIALISE()
End Sub
Public Sub Main()
' DECLARE SUB VOLUME (stype%)
' FGALAXY.BAS
' Revision 1.0 Original 22 JAN 1995
' Revision 2.0 Added ' Screen update time 16 OKT 2001
' Revision 3.0 Visual Basic June 2012
' Create pictures
'
Dim ystart% ' new display 0 = yes <>0 y value
Dim Title$
Dim stpp As Integer
Dim Ampl As Double
Dim dx1, dy1 As Double ' Main
Dim lx, ly As Double
Dim dx, dy, xstr1, ystr1, xend1, yend1 As Double
Dim x0, y0, a1, kleur, power, F1, Fn As Double
Dim ystr0, yend0 As Double
Dim xx, yy, cx, cy, cxx, cyy, cp As Double
Dim countt As Integer
Dim argbcolor As Color
' Dim patt As String
''Const ESC = 27, ENTER = 13
''Const UP = 72, DOWN = 80, LEFT = 75, RIGHT = 77
Title$ = "Fractal Galaxies Demonstration"
buffersize = 2
' ***************
If picture1 >= pictdim% Then picture1 = pictdim%
GETScreen()
' Debug.Print picture1; pictdim%
' If sheight > 1000 Then Form2.PictureBox1.Height = 1000
sheight = FGalaxyForm2.PictureBox1.Height : swidth = FGalaxyForm2.PictureBox1.Width
If trace = 1 Then Debug.Print(Text)
Text = "Main Height" + Str(sheight) + " Width" + Str(swidth)
If trace = 1 Then Debug.Print(Text)
Text = "Main stpp" + Str(stpp) + " ymax" + Str(ymax) + " ystr" + Str(ystart%) + " xmax" + Str(xmax) + " picture" + Str(picture1)
Debug.Print(Text)
' Form2.Clear() ***
Dim bmp As New Bitmap(Maxpixels, Maxpixels)
' ReDim bmp(xmax, ymax)
a4:
Ampl = Val(Me.TBamplification.Text)
If Ampl <> Amplification Or (xp1 <> 0 And xp2 = 1 And FGalaxyForm2.WindowState = 0) Then
' If Ampl <> Amplification Then
Text = "Main Amplification" + Str(Amplification) + " Ampl" + Str(Ampl) + " xp1" + Str(xp1) + " xp2" + Str(xp2)
Debug.Print(Text)
If xp1 = 0 Then
dx1 = xend(1) - xstr(1) : dy1 = yend(1) - ystr(1)
xcenter = (xend(picture1) + xstr(picture1)) / 2
ycenter = (yend(picture1) + ystr(picture1)) / 2
If Ampl > Amplification Then picture1 = picture1 + 1
Me.TBpicture.Text = picture1 ' Picture nr
picture0 = picture1 ' save to test change
xstr(picture1) = xcenter - dx1 / 2 / Ampl
xend(picture1) = xcenter + dx1 / 2 / Ampl
ystr(picture1) = ycenter - dy1 / 2 / Ampl
yend(picture1) = ycenter + dy1 / 2 / Ampl
Else
lx = xend(picture1) - xstr(picture1) : ly = yend(picture1) - ystr(picture1)
xp2 = 1 : yp2 = 1 ' one modification
xcenter = xstr(picture1) + xp1 / xp2 * lx
ycenter = ystr(picture1) + yp1 / yp2 * ly
dx1 = xend(1) - xstr(1) : dy1 = yend(1) - ystr(1)
If Ampl > Amplification Then picture1 = picture1 + 1
xstr(picture1) = xcenter - dx1 / 2 / Ampl
xend(picture1) = xcenter + dx1 / 2 / Ampl
ystr(picture1) = ycenter - dy1 / 2 / Ampl
yend(picture1) = ycenter + dy1 / 2 / Ampl
xp1 = 0 : xp2 = 1
yp1 = 0 : yp2 = 1
Me.TBpicture.Text = picture1 ' Picture nr
picture0 = picture1 ' save to test change
Me.TBxp1.Text = xp1 ' x1 %
Me.TByp1.Text = yp1 ' y1 %
Me.TBxp2.Text = xp2 ' x2 %
Me.TByp2.Text = yp2 ' y2 %
End If
Else
SETSTANDARD() 'set standard demo parameters.
End If
state = 0
xstr1 = xstr(picture1) : xend1 = xend(picture1) : ystr1 = ystr(picture1) : yend1 = yend(picture1)
dx = (xend1 - xstr1) / xmax : dy = (yend1 - ystr1) / ymax
x0 = -0.7 : y0 = 0.27 : a1 = 0.9 : kleur = 0
power = 10 ^ 10
Text = "Main dx" + Str(Int(dx * power) / power) + " dy" + Str(Int(dy * power) / power) + " xstr1" + Str(Int(xstr1 * power) / power) + " xend1" + Str(Int(xend1 * power) / power) + " ystr1" + Str(Int(ystr1 * power) / power) + " yend1" + Str(Int(yend1 * power) / power)
Debug.Print(Text)
Me.TBxcenter.Text = Int(xcenter * power) / power
' Form1.Text1(7).Text = Int(xend1 * power) / power
Me.TBycenter.Text = Int(ycenter * power) / power
' Form1.Text1(9).Text = Int(yend1 * power) / power
F1 = (xend(1) - xstr(1)) * (yend(1) - ystr(1))
Fn = (xend(picture1) - xstr(picture1)) * (yend(picture1) - ystr(picture1))
Amplification_old = Amplification
Amplification = F1 / Fn
Amplification = Int(Sqrt(Amplification) + 0.5)
Me.TBamplification.Text = Amplification
BinaryFile_Init()
ystr0 = 0 : yend0 = ymax - 1 : stpp = 1
If filenm <> "" Then ystr0 = ymax - 1 : yend0 = 0 : stpp = -1 ' bottom up
For Y% = ystr0 To yend0 Step stpp
' For Y% = 0 To ymax - 1 Step stpp
' DoEvents()
Application.DoEvents()
testblank = 0
Me.TBcmax2.Text = Str(Y%)
' Debug.Print(Str(Y%))
For X% = 0 To xmax - 1 Step 1
If X% = xmax - 1 Then testblank = 1 ' write blank
xx = xstr1 + X% * dx
yy = ystr1 + Y% * dy
cx = xx : cy = yy
countt = 0
Do
countt = countt + 1
cxx = cx * cx * (1 - a1 * cy) - cy * cy * (1 - a1 * cx) + x0
cyy = 2 * cy * cx + y0
cx = cxx : cy = cyy
cp = cx * cx + cy * cy
Loop Until cp >= 20 Or countt > 3500
GetArgbcolor(countt, argbcolor)
If countt > countmax Then countmax = countt
bmp.SetPixel(X%, Y%, argbcolor)
If filenm <> "" Then BinaryFile()
Next X%
FGalaxyForm2.PictureBox1.Image = bmp
Me.TBcmax1.Text = countmax
Next Y%
If filenm = "" Then Exit Sub
Debug.Print("Main pos" + Str(pos))
inputfile.Close()
Exit Sub
End Sub
Sub GETScreen()
' ' GET' Screen
Dim mmax As Integer
xmax = Val(FGalaxyForm2.PictureBox1.Width)
ymax = Val(FGalaxyForm2.PictureBox1.Height)
mmax = Val(Me.TBsize.Text) 'Target
If FGalaxyForm2.WindowState = 0 Then
If xmax <> mmax Or ymax <> mmax Then
' Height 0 510 Width 0 120
' Height 200 3510 Width 200 3120
' Height 300 5010 Width 300 4620
' Height 500 8010 Width 500 7620
Debug.Print("GETscreen" + Str(mmax))
FGalaxyForm2.PictureBox1.Width = mmax : xmax = mmax
FGalaxyForm2.PictureBox1.Height = mmax : ymax = mmax
FGalaxyForm2.Width = mmax + 18
FGalaxyForm2.Height = mmax + 40
FGalaxyForm2.Visible = False
Application.DoEvents()
FGalaxyForm2.Visible = True
End If
End If
End Sub
Sub INITIALISE()
' INITIALISE
picture0 = 0 ' picture number (initial )
picture1 = picture0 ' picture number
' Initialise subroutine GetArgbcolor
kl(0, 0) = 0 : kl(1, 0) = 0 : kl(2, 0) = 0 ' white
kl(0, 1) = 1 : kl(1, 1) = 0.5 : kl(2, 1) = 0.5
kl(0, 2) = 0 : kl(1, 2) = 1 : kl(2, 2) = 1
kl(0, 3) = 0.5 : kl(1, 3) = 0 : kl(2, 3) = 0.5
kl(0, 4) = 1 : kl(1, 4) = 1 : kl(2, 4) = 0
kl(0, 5) = 0 : kl(1, 5) = 0.5 : kl(2, 5) = 0.5
kl(0, 6) = 1 : kl(1, 6) = 0 : kl(2, 6) = 1
kl(0, 7) = 0.5 : kl(1, 7) = 1 : kl(2, 7) = 0.5
kl(0, 8) = 1 : kl(1, 8) = 0 : kl(2, 8) = 0
kl(0, 9) = 0.5 : kl(1, 9) = 0.5 : kl(2, 9) = 1
kl(0, 10) = 0 : kl(1, 10) = 1 : kl(2, 10) = 0
kl(0, 11) = 1 : kl(1, 11) = 0.5 : kl(2, 11) = 0.5
kl(0, 12) = 0 : kl(1, 12) = 0 : kl(2, 12) = 1
kl(0, 13) = 0.5 : kl(1, 13) = 0.5 : kl(2, 13) = 0
kl(0, 14) = 1 : kl(1, 14) = 1 : kl(2, 14) = 1 ' black
kl(0, 15) = 0 : kl(1, 15) = 0 : kl(2, 15) = 0 ' white
kl(0, 16) = 1 : kl(1, 16) = 0.5 : kl(2, 16) = 0.5
kl(0, 17) = 0 : kl(1, 17) = 1 : kl(2, 17) = 1
kl(0, 18) = 0.5 : kl(1, 18) = 0 : kl(2, 18) = 0.5
kl(0, 19) = 1 : kl(1, 19) = 1 : kl(2, 19) = 0
kl(0, 20) = 0 : kl(1, 20) = 0.5 : kl(2, 20) = 0.5
kl(0, 21) = 1 : kl(1, 21) = 0 : kl(2, 21) = 1
kl(0, 22) = 0.5 : kl(1, 22) = 1 : kl(2, 22) = 0.5
kl(0, 23) = 1 : kl(1, 23) = 0 : kl(2, 23) = 0
kl(0, 24) = 0.5 : kl(1, 24) = 0.5 : kl(2, 24) = 1
kl(0, 25) = 0 : kl(1, 25) = 1 : kl(2, 25) = 0
kl(0, 26) = 1 : kl(1, 26) = 0.5 : kl(2, 26) = 0.5
kl(0, 27) = 0 : kl(1, 27) = 0 : kl(2, 27) = 1
kl(0, 28) = 0.5 : kl(1, 28) = 0.5 : kl(2, 28) = 0
kl(0, 29) = 1 : kl(1, 29) = 1 : kl(2, 29) = 1 ' black
GETScreen()
End Sub
Sub SETSTANDARD()
' SETSTANDARD
Dim power As Long
Dim lx, ly, lx1, ly1, l1, l2 As Double
power = 10 ^ 7
' Test that both coordinates are modified
If xp2 = 1 Then xp1 = 0 : yp1 = 0
If picture1 <> picture0 Then xp1 = 0 : yp1 = 0 : xp2 = 1 : yp2 = 1
lx = xend(picture1) - xstr(picture1) : ly = yend(picture1) - ystr(picture1)
lx1 = xp2 - xp1 : ly1 = yp2 - yp1
l2 = lx1 * ly1 : l1 = Sqrt(l2)
xend(picture1 + 1) = xstr(picture1) + lx * xp2
xstr(picture1 + 1) = xstr(picture1) + lx * xp1
yend(picture1 + 1) = ystr(picture1) + ly * yp2
ystr(picture1 + 1) = ystr(picture1) + ly * yp1
Text = "SETSTANDARD" + Str(picture1) + "xp1" + Str(Int(xp1 * power) / power) + "xp2" + Str(Int(xp2 * power) / power) + "yp1" + Str(Int(yp1 * power) / power) + "yp2" + Str(Int(yp2 * power) / power) + "lx*ly" + Str(Int(l1 * power) / power)
If trace = 1 Then Debug.Print(Text)
If (xp1 <> 0 Or picture1 = 0) And l1 > 0.01 Then picture1 = picture1 + 1
xp1 = 0 : xp2 = 1
yp1 = 0 : yp2 = 1
Me.TBpicture.Text = picture1 ' Picture nr
picture0 = picture1 ' save to test change
Me.TBxp1.Text = xp1 ' x1 %
Me.TByp1.Text = yp1 ' y1 %
Me.TBxp2.Text = xp2 ' x2 %
Me.TByp2.Text = yp2 ' y2 %
Square(xstr(picture1), xend(picture1), ystr(picture1), yend(picture1))
Text = "SETSTANDARD" + Str(picture1) + Str(Int(xstr(picture1) * power) / power) + Str(Int(xend(picture1) * power) / power) + Str(Int(ystr(picture1) * power) / power) + Str(Int(yend(picture1) * power) / power) + "lx*ly" + Str(Int(l1 * power) / power)
If trace = 1 Then Debug.Print(Text)
End Sub
Public Sub GetArgbcolor(ByVal ip As Integer, ByRef argbcolor As Color)
Dim jmax, n, ns, i As Integer
Dim expp, j, ip1 As Double
Dim deltakl As Double
Dim rgbx(2) As Integer ' GETcoulour1
Dim alpha, red, green, blue As Single
jmax = 5
n = 1
ns = 50
' Form2.DrawWidth = n
ip1 = ip - 1
expp = Exp(-ip1 / 280)
ip1 = ip1 * expp
j = ip1 / jmax
i = Int(j)
j = j - i
If i > 28 Then i = 29 : j = 1
For ikl = 0 To 2
deltakl = kl(ikl, i + 1) - kl(ikl, i)
rgbx(ikl) = kl(ikl, i) * 255 + Int(deltakl * 255 * j)
Next ikl
' Debug.Print("GetArgbcolor ip" + Str(ip) + " ip1" + Str(Int(ip1 * 100) / 100) + " i" + Str(i) + " j" + Str(Int(j * 100) / 100))
' red = 255: green = 0: blue = 0
' rgbx(0) = red: rgbx(1) = green: rgbx(2) = blue
' colour = RGB(rgbx(0), rgbx(1), rgbx(2)) ' red green blue
red = rgbx(0) : green = rgbx(1) : blue = rgbx(2) : alpha = 255
argbcolor = Color.FromArgb(alpha, red, green, blue)
End Sub
Public Sub Square(ByRef xp1, ByRef xp2, ByRef yp1, ByRef yp2)
Dim X1, X2, Y1, Y2, area, lx, ly As Double
Dim dx, dy As Double
' Debug.Print "Square"; xp1; "xp2"; xp2; "yp1"; yp1; "yp2"; yp2
' adjust the coordinates to square
X1 = xp1 : X2 = xp2 : Y1 = yp1 : Y2 = yp2
dx = X2 - X1 : dy = Y2 - Y1
area = dx * dy
lx = Sqrt(area * swidth / sheight) : ly = area / lx
xcenter = (X1 + X2) / 2 : ycenter = (Y1 + Y2) / 2
xp1 = xcenter - lx / 2 : xp2 = xcenter + lx / 2
yp1 = ycenter - ly / 2 : yp2 = ycenter + ly / 2
' Debug.Print X, Y, l
Debug.Print("Square " + Str(xp1) + "xp2" + Str(xp2) + "yp1" + Str(yp1) + "yp2" + Str(yp2) + Str(swidth) + Str(sheight))
End Sub
Public Sub BinaryFile_Init()
Dim hdr(13) As Long
Dim area As Double
Dim patt As String
Dim Numberofrecords As Long
Dim width2 As Integer
Dim lheader = 26
Dim bytes = New Byte(buffersize - 1) {}
width1 = swidth
height1 = sheight
filenm = LTrim$(Me.TBfilename.Text)
dirname = LTrim$(Me.TBdirname.Text)
' C:\Users\Gebruiker\Documents\Visual Studio 2010\Projects\VB2010 FGalaxy\VB2010 FGalaxy\bin\Debug
If filenm = "" Then Exit Sub
filenm = dirname + filenm
filenm = filenm + "." + LTrim$(Str(width1)) + "." + LTrim$(Str(Amplification))
filenm = filenm + ".X" + LTrim$(Str(xcenter)) + ".Y" + LTrim$(Str(ycenter)) + ".BMP"
Dim file As System.IO.FileStream
file = System.IO.File.Create(filenm)
file.Close()
Application.DoEvents()
inputfile = IO.File.Open(filenm, IO.FileMode.Open)
Numberofrecords = 0 ' LOF(1) ***
Debug.Print(filenm + " Numberofrecords" + Str(Numberofrecords))
hdr(1) = Asc("M") * 256 + Asc("B")
width2 = width1
blank = width1 Mod 4
area = (width1 * 3 + blank) * height1 + lheader
hdr(2) = area
hdr(3) = 0
Debug.Print("BinaryFile_Init width1" + Str(width1) + Str(height1) + Str(area))
If area > 2 ^ 16 Then
hdr(3) = Int(area / 2 ^ 16)
hdr(2) = area - hdr(3) * 2 ^ 16
End If
hdr(6) = lheader
hdr(8) = 12
hdr(10) = width1
hdr(11) = height1
hdr(12) = 1
hdr(13) = 16 + 8
pos = 1
patt = ""
For i = 1 To 13
bytes(0) = hdr(i) Mod 256
bytes(1) = Int(hdr(i) / 256)
inputFile.Write(bytes, 0, buffersize)
Hex(hdr(i), patt)
If trace = 1 Then Debug.Print("BinaryFile_Init " + Str(pos) + Str(hdr(i)) + patt)
pos = pos + 2
Next i
ipnt = 0
End Sub
Public Sub BinaryFile()
Dim in1 As Long
Dim in2 As Integer
Dim rgb1(3) As Long
Dim patt As String
Dim bytes = New Byte(buffersize - 1) {}
''red = 0: green = 8 * 16: blue = 8 * 16
''red = 15 * 16: green = 0: blue = 0 ' red 0000FF
''red = 15 * 16: green = 8 * 16: blue = 0 ' orange 0000FF
''rgb1(0) = blue: rgb1(1) = green: rgb1(2) = red: rgb1(3) = blue
rgb1(0) = rgbx(2) : rgb1(1) = rgbx(1) : rgb1(2) = rgbx(0)
rgb1(3) = rgb1(0)
var(ipnt) = rgb1(0)
var(ipnt + 1) = rgb1(1)
var(ipnt + 2) = rgb1(2)
bytes(0) = var(0)
bytes(1) = var(1)
inputfile.Write(bytes, 0, buffersize)
If pos < posmax And trace = 1 Then
patt = ""
Hex(in2, patt)
Debug.Print("BinaryFile pos " + Str(pos) + Str(in2) + patt)
End If
pos = pos + 2
ipnt = ipnt + 1
var(0) = var(2)
var(1) = var(3)
If ipnt = 2 Or (testblank = 1 And blank Mod 2 = 1) Then
in1 = var(1) * 256 + var(0) ' long
in2 = in1
bytes(0) = in2 Mod 256
bytes(1) = Int(in2 / 256)
inputfile.Write(bytes, 0, buffersize)
patt = ""
If pos < posmax And trace = 1 Then
Hex(in2, patt)
Debug.Print("BinaryFile pos " + Str(pos) + Str(in2) + patt)
End If
pos = pos + 2
ipnt = 0
End If
If testblank = 1 And blank >= 2 Then
bytes(0) = 0
bytes(1) = 0
inputfile.Write(bytes, 0, buffersize)
pos = pos + 2
End If
End Sub
Public Sub Hex(ByVal in1 As Long, ByRef a$)
Dim a1(8)
Dim signx, in2 As Integer
Dim r, chr1 As String
in2 = in1
signx = 0
If in2 < 0 Then in2 = 2 ^ 31 + in1 : signx = 1
r = "" : chr1 = "" ' ** 611
For i = 0 To 8
a1(i) = in2 Mod 16
in2 = Int(in2 / 16)
If i = 7 And signx = 1 Then a1(i) = a1(i) + 8
If a1(i) < 10 Then
chr1 = Chr(Asc("0") + a1(i)) ' ***
Else
chr1 = Chr(Asc("A") + a1(i) - 10) ' ***
End If
r = chr1 + r
' Debug.Print i; in2; a1(i); chr1; r
Next i
a$ = r
' Debug.Print("Hex " + a$)
End Sub
End Class